home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / lineio.scm.z / lineio.scm
Encoding:
Text File  |  1999-04-16  |  3.7 KB  |  114 lines
  1. ;;; installed-scm-file
  2.  
  3. ;;;;     Copyright (C) 1996, 1998 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20.  
  21.  
  22.  
  23. (define-module (ice-9 lineio))
  24.  
  25.  
  26. ;;; {Line Buffering Input Ports}
  27. ;;;
  28. ;;; [This is a work-around to get past certain deficiencies in the capabilities
  29. ;;;  of ports.  Eventually, ports should be fixed and this module nuked.]
  30. ;;;
  31. ;;; A line buffering input port supports:
  32. ;;;
  33. ;;;     read-string      which returns the next line of input
  34. ;;;    unread-string     which pushes a line back onto the stream
  35. ;;; 
  36. ;;; The implementation of unread-string is kind of limited; it doesn't
  37. ;;; interact properly with unread-char, or any of the other port
  38. ;;; reading functions.  Only read-string will get you back the things that
  39. ;;; unread-string accepts.
  40. ;;;
  41. ;;; Normally a "line" is all characters up to and including a newline.
  42. ;;; If lines are put back using unread-string, they can be broken arbitrarily
  43. ;;; -- that is, read-string returns strings passed to unread-string (or 
  44. ;;; shared substrings of them).
  45. ;;;
  46.  
  47. ;; read-string port
  48. ;; unread-string port str
  49. ;;   Read (or buffer) a line from PORT.
  50. ;;
  51. ;; Not all ports support these functions -- only those with 
  52. ;; 'unread-string and 'read-string properties, bound to hooks
  53. ;; implementing these functions.
  54. ;;
  55. (define-public (unread-string str line-buffering-input-port)
  56.   ((object-property line-buffering-input-port 'unread-string) str))
  57.  
  58. ;;
  59. (define-public (read-string line-buffering-input-port)
  60.   ((object-property line-buffering-input-port 'read-string)))
  61.  
  62.  
  63. (define-public (lineio-port? port)
  64.   (not (not (object-property port 'read-string))))
  65.  
  66. ;; make-line-buffering-input-port port
  67. ;;   Return a wrapper for PORT.  The wrapper handles read-string/unread-string.
  68. ;;
  69. ;; The port returned by this function reads newline terminated lines from PORT.
  70. ;; It buffers these characters internally, and parsels them out via calls
  71. ;; to read-char, read-string, and unread-string.
  72. ;;
  73.  
  74. (define-public (make-line-buffering-input-port underlying-port)
  75.   (let* (;; buffers - a list of strings put back by unread-string or cached
  76.      ;; using read-line.
  77.      ;;
  78.      (buffers '())
  79.  
  80.      ;; getc - return the next character from a buffer or from the underlying
  81.      ;; port.
  82.      ;;
  83.      (getc (lambda ()
  84.          (if (not buffers)
  85.              (read-char underlying-port)
  86.              (let ((c (string-ref (car buffers))))
  87.                (if (= 1 (string-length (car buffers)))
  88.                (set! buffers (cdr buffers))
  89.                (set-car! buffers (make-shared-substring (car buffers) 1)))
  90.                c))))
  91.  
  92.      (propogate-close (lambda () (close-port underlying-port)))
  93.  
  94.      (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
  95.  
  96.      (unread-string (lambda (str)
  97.               (and (< 0 (string-length str))
  98.                    (set! buffers (cons str buffers)))))
  99.  
  100.      (read-string (lambda ()
  101.                (cond
  102.             ((not (null? buffers))
  103.              (let ((answer (car buffers)))
  104.                (set! buffers (cdr buffers))
  105.                answer))
  106.             (else
  107.              (read-line underlying-port 'concat)))))) ;handle-newline->concat
  108.  
  109.     (set-object-property! self 'unread-string unread-string)
  110.     (set-object-property! self 'read-string read-string)
  111.     self))
  112.  
  113.  
  114.